Celestin Apprentice 7/Apprentice-Release7.iso/Environments/Clean 1.2.4/IOInterface/scrollList.icl

Modula Implementation | 1997-04-23 | 16.1 KB | 476 lines | [TEXT/3PRM]

implementation module scrollList;

/* General Scrolling List implementation. */

import StdClass, StdInt, StdString, StdChar, StdBool,StdArray;
import deltaDialog, deltaEventIO, deltaTimer, deltaFont, deltaPicture, deltaSystem;
import commonDef;

::    NrVisible          :== Int;

ChangeI                :== 0;
NrVisI                :== 1;
WidthI                :== 2;
FirstI                :== 4;
DefltI                :== 6;
FirstItemIndex        :== 8;
ItemWid width        :== width - 13;
DownTop nr ht        :== DownBot nr ht - ArrowHgt;
DownBot nr ht        :== nr * ht;
UpTop                :== 0;
UpBot                :== ArrowHgt;
ArrowHgt            :== 17;
NoAction            :== '0';
Selected            :== '1';
ScrolledUp            :== '2';
ScrolledDown        :== '3';
EndOfList            :== '\\';        // there is no test on the value of EndOfList

ScrollListError :: String String Int -> * x;
ScrollListError rule message id
    =    Error rule "scrollList" (message +++ " (item id = " +++ toString id +++ ")");


//
//    The ScrollingList item definition.
//

ScrollingList    ::    !DialogItemId !ItemPos !Measure !SelectState !NrVisible !ItemTitle ![ItemTitle]
                    !(DialogFunction s (IOState s))
                ->    DialogItem s (IOState s);
ScrollingList id pos minWidth select nrVisible defaultItem items dialogF
    =    Control id pos ((-1,-1),(width,height)) select cState (ScrollLook font width at_new lineH)
            (ScrollFeel width at_new lineH) (ScrollDFunc id dialogF);
    where {
        cState                = StringCS (SetWidth width sState);
        (maxWidth, sState)    = InitScrollState font nrVisible defaultItem items;
        width                = Max (MeasureToHorPixels minWidth) maxWidth + 20;
        height                = inc (nrVisible * lineH);
        lineH                = at_new + dt + ld;
        (at_new, dt, mw, ld)= FontMetrics font;
        (b, font)            = SelectFont name style size;
        (name, style, size)    = DefaultFont;
    };


/*    The initial ControlState. */

InitScrollState :: !Font !Int !ItemTitle ![ItemTitle] -> (!Int, !String);
InitScrollState font nrVisible defaultItem items
    =    (maxWidth, SetNewFirst (nrVisible - realNrVisible) first state);
    where {
        (maxWidth,state)= CreateScrollState font nrVisible "" 0 False FirstItemIndex defaultItem items;
        realNrVisible    = NrItemsVisible nrVisible 0 first state;
        first            = GetFirstIndex state;
    };

CreateScrollState :: !Font !Int !String !Int !Bool !Int !ItemTitle ![ItemTitle]
    -> (!Int, !String);
CreateScrollState font nrVisible state maxWidth found index defaultItem [item : items]
|    found || defaultItem == item
    = CreateScrollState font nrVisible state` maxWidth` True index defaultItem items;
    = CreateScrollState font nrVisible state` maxWidth` found (index + length) defaultItem items;
    where {
        state`        = state +++ item +++ "\n";
        maxWidth`    = Max maxWidth (FontStringWidth item font);
        length        = inc (size item);
    };
CreateScrollState font nrVisible state maxWidth found index defaultItem items
|    found
    = (maxWidth, SetFirstIndex index (SetDefltIndex index state`));
    = (maxWidth, SetFirstIndex FirstItemIndex (SetDefltIndex FirstItemIndex state`));
    where {
        state` = ((toString Selected +++ toString (toChar nrVisible)) +++ "      ") +++ state +++ toString EndOfList;
    };

NrItemsVisible :: !Int !Int !Int !String -> Int;
NrItemsVisible nrVisible itemNr index state
|    nrVisible == 0 || noMore    = itemNr;
                                = NrItemsVisible (dec nrVisible) (inc itemNr) index` state;
    where {
        (noMore, index`, item)    = GetItem index state;
    };

SetNewFirst    :: !Int !Int !String -> String;
SetNewFirst itemNr index state
|    itemNr <= 0 || noMore        = SetFirstIndex index state;
                                = SetNewFirst (dec itemNr) index` state;
    where {
        (noMore, index`, item)    = GetScrolledDownItem index state;
    };


/*    The ControlLook. */

ScrollLook :: !Font !Int !Int !Int !SelectState !ControlState -> [DrawFunction];
ScrollLook font width ascent lineH select (StringCS state)
    =    [frame,move,line,items : arrows];
    where {
        items        = DrawItemTitles able nrVisible ascent lineH first width defId state;
        able        = Enabled select;
        arrows        = DrawArrows width height select state;
        frame        = DrawRectangle ((-1,-1), (width,height));
        move        = MovePenTo (ItemWid width,-1);
        line        = LinePen (0, height);
        height        = inc (nrVisible * lineH);
        nrVisible    = GetNrVis state;
        first        = GetFirstIndex state;
        defId        = GetDefltIndex state;
    };

DrawArrows :: !Int !Int !SelectState !String -> [DrawFunction];
DrawArrows width height Able state
|    up && down        = [up1,up2,up3,down1,down2,down3];
|    down            = [up1,up2,up3];
|    up                = [down1,down2,down3];
                    = [];
    where {
        (up, down)    = CanScroll state;
        up1            = FillPolygon upArrow;
        up2            = FillPolygon (MovePolygon (0,3) upArrow);
        up3            = FillPolygon (MovePolygon (0,9) upArrow);
        down1        = FillPolygon downArrow;
        down2        = FillPolygon (MovePolygon (0,-3) downArrow);
        down3        = FillPolygon (MovePolygon (0,-9) downArrow);
        upArrow        = ((width - 7, 2), [(4,4), (-8,0)]);
        downArrow    = ((width - 7, height - 3), [(-4,-4), (8,0)]);
    };
DrawArrows width height unable state
|    up && down        = [up1,down1];
|    down            = [up1];
|    up                = [down1];
                    = [];
    where {
        (up, down)    = CanScroll state;
        up1            = DrawPolygon ((width - 7, 2), [(4,4), (-8,0)]);
        down1        = DrawPolygon ((width - 7, height - 3), [(-4,-4), (8,0)]);
    };

DrawItemTitles    :: !Bool !Int !Int !Int !Int !Int !Int !String !Picture -> Picture;
DrawItemTitles able nr base lineH index width defId state pic
|    nr == 0 || noMore        = pic;
|    defItem && able            = DrawItemTitles able (dec nr) base` lineH index` width defId state pic1;
|    defItem                    = DrawItemTitles able (dec nr) base` lineH index` width defId state pic2;
                            = DrawItemTitles able (dec nr) base` lineH index` width defId state pic3;
    where {
        (noMore,index`,item)= GetItem index state;
        pic1                = SelectItem        width defY lineH pic3;
        pic2                = UnableSelectItem    width defY lineH pic3;
        pic3                = DrawString item (MovePenTo (3,base) pic);
        base`                = base + lineH;
        defY                = base - base mod lineH;
        defItem                = index == defId;
    };

SelectItem :: !Int !Int !Int !Picture -> Picture;
SelectItem width y lineH pic
    =  SetPenMode CopyMode (
            FillRectangle ((0,y),(ItemWid width, y + lineH)) (
            SetPenMode HiliteMode pic));

UnableSelectItem :: !Int !Int !Int !Picture -> Picture;
UnableSelectItem width y lineH pic
    =  SetPenMode CopyMode (
            DrawRectangle ((0,y),(ItemWid width, y + lineH)) (
            SetPenMode HiliteMode pic));


/*    The ControlFeel. */

ScrollFeel :: !Int !Int !Int !MouseState !ControlState -> (!ControlState, ![DrawFunction]);
ScrollFeel width ascent lineH (pos, ButtonUp, mods) (StringCS state)
|    action == ScrolledUp
||    action == ScrolledDown        = (state`, [erase : arrows]);
                                = (state`, []);
    where {
        state`    = StringCS (SetAction NoAction state);
        erase    = EraseRectangle ((inc (ItemWid width), UpTop), (dec width, DownBot nrVis lineH));
        arrows    = DrawArrows width (inc (nrVis * lineH)) Able state;
        action    = GetAction state;
        nrVis    = GetNrVis  state;
    };
ScrollFeel width ascent lineH ((x,y), ButtonStillDown, mods) (StringCS state)
| action == ScrolledDown        = ScrollDown width ascent lineH nrVis y state;
| action == ScrolledUp            = ScrollUp   width ascent lineH nrVis y state;
                                = (StringCS state`, []);
    where {
        state`    = SetAction NoAction state;
        nrVis    = GetNrVis  state;
        action    = GetAction state;
    };
ScrollFeel width ascent lineH ((x,y), buttonDown, mods) (StringCS state)
|    InItemList  width lineH nrVis x y            = SelectNewItem defNr lineH width
                                                    (SetAction NoAction state);
|    OnUpArrow   width x y              && down    = (state1, [HiliteArrow width UpTop        : draws1]);
|    OnDownArrow width lineH nrVis x y && up        = (state2, [HiliteArrow width downTop    : draws2]);
                                                = (StringCS (SetAction NoAction state), []);
    where {
        (state1, draws1)    = ScrollDown width ascent lineH nrVis y (SetAction ScrolledDown state);
        (state2, draws2)    = ScrollUp   width ascent lineH nrVis y (SetAction ScrolledUp    state);
        (up, down)            = CanScroll state;
        downTop                = DownTop nrVis lineH;
        nrVis                = GetNrVis state;
        defNr                = y / lineH;
    };

SelectNewItem :: !Int !Int !Int !String -> (!ControlState, ![DrawFunction]);
SelectNewItem defNr lineH width state
|    inList    = (StringCS state`, draws`);
            = (StringCS state,  []);
    where {
        (inList,state`,draws)    = SelNewItem defNr 0 lineH first defId width state;
        draws`                    = UnSelOldItem nrVis 0 lineH first defId width state` draws;
        defId                    = GetDefltIndex state;
        first                    = GetFirstIndex state;
        nrVis                    = GetNrVis        state;
    };

SelNewItem :: !Int !Int !Int !Int !Int !Int !String -> (!Bool, !String, ![DrawFunction]);
SelNewItem nr y lineH index defId width state
|    (found && index == defId) || noMore    = (False, state, []);
|    found                                = (True, state`, [SelectItem width y lineH]);
                                        = SelNewItem (dec nr) (y+lineH) lineH index` defId width state;
    where {
        (noMore, index`, item)    = GetItem index state;
        found                    = nr == 0;
        state`                    = SetAction Selected (SetDefltIndex index state);
    };

UnSelOldItem :: !Int !Int !Int !Int !Int !Int !String ![DrawFunction] -> [DrawFunction];
UnSelOldItem nr y lineH index defId width state draws
|    nr == 0 || noMore    = draws;
|    index == defId        = [SelectItem width y lineH : draws];
                        = UnSelOldItem (dec nr) (y + lineH) lineH index` defId width state draws;
    where {
        (noMore, index`, item) = GetItem index state;
    };

ScrollDown :: !Int !Int !Int !Int !Int !String -> (!ControlState, ![DrawFunction]);
ScrollDown width ascent lineH nrVis y state
|    y >= UpBot || noMore    = (StringCS state, []);
|    defId == first`            = Wait ticks (StringCS state`, [scroll,erase,move,drawit,select]);
                            = Wait ticks (StringCS state`, [scroll,erase,move,drawit]);
    where {
        (noMore,first`,item)= GetScrolledDownItem first state;
        state`                = SetFirstIndex first` state;
        first                = GetFirstIndex state;
        defId                = GetDefltIndex state;
        scroll                = CopyRectangle ((0,0),(right,bottom)) (0,lineH);
        right                = ItemWid width;
        bottom                = lineH * dec nrVis;
        erase                = EraseRectangle ((0,top`),(right,bottom`));
        (top`, bottom`)        = If (lineH < 0) (bottom + lineH, bottom) (0, lineH);
        move                = MovePenTo (3,ascent);
        drawit                = DrawString item;
        select                = SelectItem width 0 lineH;
        ticks                 = WaitInterval (UpBot - y);
    };

GetScrolledDownItem    :: !Int !String -> (!Bool, !Int, !String);
GetScrolledDownItem index state
|    index == FirstItemIndex    = (True, index, "");
                            = (False, i, state % (i, index`));
    where {
        i        = FindPreviousItemIndex index` state;
        index`    = index-2;
    };

ScrollUp :: !Int !Int !Int !Int !Int !String -> (!ControlState, ![DrawFunction]);
ScrollUp width ascent lineH nrVis y state
|    y <= DownTop nrVis lineH ||    noMore    = (StringCS state, []);
|    defId == lastid                        = Wait ticks (StringCS state`,[scroll,erase,move,drawit,select]);
                                        = Wait ticks (StringCS state`,[scroll,erase,move,drawit]);
    where {
        (b, first`, it)        = GetItem first state;
        (noMore,lastid,item)= GetScrolledUpItem (dec nrVis) first` state;
        state`                = SetFirstIndex first` state;
        first                = GetFirstIndex state;
        defId                = GetDefltIndex state;
        scroll                = CopyRectangle ((0,lineH),(right,bottom)) (0,0 - lineH);
        right                = ItemWid width;
        bottom                = nrVis * lineH;
        erase                = EraseRectangle ((0,top`),(right,bottom`));
        (top`, bottom`)        = If (lineH < 0) (lineH, 0) (bottom - lineH, bottom);
        move                = MovePenTo (3,newy + ascent);
        drawit                = DrawString item;
        select                = SelectItem width newy lineH;
        newy                = lineH *  dec nrVis;
        ticks                 = WaitInterval (y - DownTop nrVis lineH );
    };

GetScrolledUpItem :: !Int !Int !String -> (!Bool, !Int, !String);
GetScrolledUpItem nr index state
|    nr == 0 || noMore    = (noMore, index, item);
                        = GetScrolledUpItem (dec nr) index` state;
    where {
        (noMore, index`, item) = GetItem index state;
    };

CanScroll :: !String -> (!Bool, !Bool);
CanScroll state
    =    (not up, not down);
    where {
        (up,    f2, i2)    = GetScrolledUpItem nrVis first state;
        (down,    f1, i1)    = GetScrolledDownItem first state;
        first            = GetFirstIndex state;
        nrVis            = GetNrVis state;
    };

WaitInterval :: !Int -> Int;
WaitInterval i
|    i <= 0    = TicksPerSecond / 6;
            = (TicksPerSecond / inc (i / 5) ) / 6;

HiliteArrow :: !Int !Int !Picture -> Picture;
HiliteArrow width top pic
    =    SetPenMode CopyMode (
            FillRectangle ((l,top),(r,b)) (
            SetPenMode XorMode pic));
    where {
        l = inc (ItemWid width);
        r = dec width;
        b = top + ArrowHgt;
    };

InItemList :: !Int !Int !Int !Int !Int -> Bool;
InItemList width ht nr x y
    =    x >= 0 && x <= ItemWid width && (y >= 0 && y <= nr * ht);

OnUpArrow :: !Int !Int !Int -> Bool;
OnUpArrow width x y
    =    x > ItemWid width && x < width && (y >= UpTop && y <= UpBot);

OnDownArrow :: !Int !Int !Int !Int !Int -> Bool;
OnDownArrow width ht nr x y
    =    x > ItemWid width && x < width && (y >= DownTop nr ht && y <= DownBot nr ht);


/*    The dialog function. */

ScrollDFunc    ::    !DialogItemId !(DialogFunction s (IOState s)) !DialogInfo
                !(DialogState s (IOState s))
            ->      DialogState s (IOState s);
ScrollDFunc id dialogF info dState
|    GetAction cState == Selected    = dialogF info dState;
                                    = dState;
    where {
        (isScrollList, cState)        = GetScrollState id info;
    };

GetScrollState :: !DialogItemId !DialogInfo -> (!Bool, !String);
GetScrollState id info = GetScrollStateFromControl (GetControlState id info);

GetScrollStateFromControl :: !ControlState -> (!Bool, !String);
GetScrollStateFromControl (StringCS state)    = (True, state);
GetScrollStateFromControl _                    = (False, "");


//
//    The function to change the scrolling list.
//

ChangeScrollingList    ::    !DialogItemId !ItemTitle ![ItemTitle]
                        !(DialogState s (IOState s))
                    ->      DialogState s (IOState s);
ChangeScrollingList id defItem items dState
|    isScrollList    = ChangeControlState id cState dState`;
                    = ScrollListError "ChangeScrollingList" "Item is not a ScrollingList" id;
    where {
        cState                    = StringCS (SetWidth width state);
        (maxWidth, state)        = InitScrollState font nrVis defItem items;
        width                    = GetWidth oldState;
        (b, font)                = SelectFont name style size;
        (name, style, size)        = DefaultFont;
        nrVis                    = GetNrVis oldState;
        (isScrollList, oldState)= GetScrollState id info;
        (info, dState`)            = DialogStateGetDialogInfo dState;
    };


//
//    The functions to retrieve the selected item in the scrolling list.
//

GetScrollingListItem :: !DialogItemId !DialogInfo -> ItemTitle;
GetScrollingListItem id info
|    isScrollList    = item;
                    = ScrollListError "GetScrollingListItem" "Item is not a ScrollingList" id;
    where {
        (b, i, item)            = GetItem (GetDefltIndex state) state;
        (isScrollList, state)    = GetScrollState id info;
    };


/*    Access functions to the ControlState. */

GetItem    :: !Int !String -> (!Bool, !Int, !String);
GetItem index state
//    -> (TRUE, index, ""),    IF =C (INDEX state index) EndOfList        == alternative changed
|    dec (size state)  == index    = (True, index, "");            // into this one
                                    = (False, inc i, state % (index, dec i));
    where {
        i = NextNlIndex index state;
    };

NextNlIndex    :: !Int !String -> Int;
NextNlIndex i str
|    str.[i] == '\n'    = i;
                            = NextNlIndex (inc i) str;

FindPreviousItemIndex :: !Int !String -> Int;
FindPreviousItemIndex i str
|    i < FirstItemIndex        = FirstItemIndex;
|    str.[i] == '\n'    = inc i;
                            = FindPreviousItemIndex (dec i) str;

GetAction :: !String -> Char;
GetAction state = state.[ChangeI];

SetAction :: !Char !String -> String;
SetAction action state = state := (ChangeI, action);

GetNrVis :: !String -> Int;
GetNrVis state = toInt (state.[NrVisI]);

GetWidth :: !String -> Int;
GetWidth state = GetNrFromState WidthI state;

SetWidth :: !Int !String -> !String;
SetWidth width state = SetNrInState WidthI width state;

GetFirstIndex :: !String -> Int;
GetFirstIndex state = GetNrFromState FirstI state;

SetFirstIndex :: !Int !String -> String;
SetFirstIndex first state = SetNrInState FirstI first state;

GetDefltIndex :: !String -> Int;
GetDefltIndex state = GetNrFromState DefltI state;

SetDefltIndex :: !Int !String -> String;
SetDefltIndex deflt state = SetNrInState DefltI deflt state;

GetNrFromState :: !Int !String -> Int;
GetNrFromState index state
    =    toInt c0 + 256 * toInt c1;
    where {
        c0 = state.[index];
        c1 = state.[inc index];
    };

SetNrInState :: !Int !Int !String -> !String;
SetNrInState index nr state
    =    (state := (index, c0)) := (inc index, c1);
    where {
        c0 = toChar (nr mod 256);
        c1 = toChar (nr / 256);
    };


/* Misc. functions */

MeasureToHorPixels :: !Measure        -> Int;
MeasureToHorPixels (MM        mm)        = MMToHorPixels        mm;
MeasureToHorPixels (Inch    inch)    = InchToHorPixels    inch;
MeasureToHorPixels (Pixel    p)        = p;